#
# Classifier for Exchange messages
#
package Mail::Bounce::Exchange;

use strict;

use vars qw(@ISA @patterns $DEBUG);

@ISA = qw(Mail::Bounce::Heuristic);
$DEBUG = 0;

# Note - To: line can give email address OR internal name of person
# Note - the section with final recipient gets unwrapped before match

$patterns[0] = << 'EoF';
Your message

  To:      ${RECIP-.*}
  Subject: ${-.*}
  Sent:    ${-.*}

did not reach the following recipient(s):

${FINAL_RECIPIENT-\S.*} on ${FAIL_DATE-\S\S\S\,.+ \S\d\d\d\d}
    ${DIAGNOSTIC-.*}
EoF

    # override the firstbodystring() function, because:

    # - At least Internet Mail Service 5.5.2653.19 @desc.dla.mil is capable of
    # returning flattened bounces instead of multipart bounces
    # Other Exchange bounces have come in as multipart.
    # - there was a "feature" at isinet.com that alternatived the report
    # Internet Mail Service 5.5.2448.0

sub firstbodystring {
    my $self = shift;
    
    if ($self->is_multipart) {
	if ($self->parts(0)->is_multipart) {
	    # multipart/alternative - see isinet.com
	    $DEBUG && warn "Multipart first - picking first part of that\n";
	    return $self->parts(0)->parts(0)->bodyhandle->as_string;
	} else {
	    return $self->parts(0)->bodyhandle->as_string;
	}
    } else {
	return $self->bodyhandle->as_string;
    }
}


sub validate {
    my $self = shift;
    my $string = recipunwrap($self->firstbodystring());
    my $keywords = $self->patternmatch($string, @patterns);
    return defined($keywords);
}

    

sub recipients {
    my $self = shift;

    if (wantarray()) {
	my $res;
	my $body;
	if ($self->is_multipart()) {
	    my $report = $self->parts(0);
	    $body = $report->bodyhandle();
	} else {
	    $body = $self->bodyhandle();
	}
	my $keywords = $self->patternmatch(recipunwrap($self->firstbodystring()), @patterns);
	if (defined($keywords)) {
	    $res = new Mail::Bounce::Address;
	    $res->type("permfail");
	    $res->action("failed");
	    $res->status("5.1.1 (Unknown user)");
	    # this silliness is because of a single charset-challenged
	    # gateway in Sweden...
	    if ($$keywords{FINAL_RECIPIENT} =~ /\?/
		&& $$keywords{FINAL_RECIPIENT} !~ /\@/) {
		$$keywords{FINAL_RECIPIENT} =~ s/\?/@/;
	    }
	    if ($$keywords{FINAL_RECIPIENT} =~ /^\S+@\S+$/) {
		$res->final_recipient("RFC822; " . $$keywords{FINAL_RECIPIENT});
	    } else {
		$res->final_recipient("RFC822; " . $$keywords{RECIP});
	    }
	} else {
	    die "Exchange: Unmatched pattern in recipients()\n";
	}
	return $res;
    } else {
	return 1;
    }
}

# weirdness because wrapping often occurs
sub recipunwrap {
    my $string = shift;
    if ($string =~ /recipient\(s\):\n\n(\S.*?[\s\n]on[\s\n].*?[\s\n][+-]\d{4})\n/s) {
	my $wrap = $1;
	my $unwrap = $wrap;
	$wrap = "\Q$wrap";
	$unwrap =~ tr/\n/ /;
        $DEBUG && warn "Unwrapping $wrap to $unwrap\n";
	$string =~ s/$wrap/$unwrap/;
    } else {
	$DEBUG && warn "did not find user block\n";
    }
    $string;
}

1;




